perm filename OMULTL.LOS[QLA,LSP] blob
sn#740823 filedate 1984-01-23 generic text, type C, neo UTF8
COMMENT ā VALID 00019 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 Simulator for Multi-processing Lisp.
C00009 00003 Defstructs
C00020 00004 Metering
C00023 00005 Process Loop
C00033 00006 Environment Stuff
C00036 00007 Simple Interpreter M-EVAL
C00052 00008 Simple Interpreter M-APPLY
C00064 00009 COND, OR, AND, NOT
C00067 00010 PROGN
C00069 00011 SETQ
C00071 00012 QLAMBDA
C00084 00013 CATCH/THROW
C00089 00014 DO
C00093 00015 Definitions
C00094 00016 Simple Allocation Routines
C00096 00017 Simple 1-dimensional array stuff
C00097 00018 Useful Macros for the Running System.
C00098 00019 Startup
C00102 ENDMK
Cā;
;;; Simulator for Multi-processing Lisp.
;;; Things changed since 3600 version:
;;; *global-read-time* and all read-conflict stuff.
;;; addition of m-init-world.
;;; changing to closure environments, not adding them.
;;; Environment restoration in eval-form and eval-forms
(declare
(mapex t)
(fixsw t)
(setq defmacro-for-compiling ())
(setq backquote-expand-when 'read)
(or (get 'defstruct 'version)
(fasload struct fas lisp)))
(declare (special *meter* *function* *process-creation-time* *read-time*
*val* *write-time* *points* *graphp* *xfun* *yfun* *silence* *time*
*pc-stack* *arg-stack* *environment* *machine* *self* *valuep* *recent-vars*
*tag* *catch-thread* *pc-stack* *arg-stack* *evarg-stack* *variable-conflict-window*
*allocate-stack*))
(declare (special *number-of-processes*)
(fixnum *number-of-processes*))
(declare (special *max-number-of-processes*)
(fixnum *max-number-of-processes*))
(setq *number-of-processes* 0)
;;; *VALUEP* can be one of:
;;; tail-recursive = this is a tail recursive call forming the value of the function
;;; argument = this is a call whose value is a argument to something else
;;; () = the value of this call can be thrown away
(setq *number-of-processes* 0)
(setq *process-creation-time* 0)
(setq *time* 0)
(setq *variable-conflict-window* 0)
(setq *read-time* 0)
(setq *write-time* 0)
(setq *graphp* () *silence* ())
(setq *xfun* () *yfun* ())
(defmacro m-init-world ()
`(setq *pc-stack* () *arg-stack* () *evarg-stack* () *environment* ()
*number-of-processes* 0 *allocate-stack* ()
*recent-vars* () *valuep* ()))
(eval-when (load) (*rset (nouuo ()))
(setq base 10. ibase 10.))
(defstruct queue
(qhead ())
(qtail ()))
(defun queue-head (q) (car (qhead q)))
(defun queue-tail (q) (car (qtail q)))
(defun next-queue (q) (cadr (qhead q)))
(defun add-queue (item q)
(cond ((null (qhead q))
(let ((x (ncons item)))
(setf (cdr x) x)
(setf (qhead q) x)
(setf (qtail q) x)
item))
(t
(let ((x (ncons item)))
(setf (cdr x) (qhead q))
(setf (cdr (qtail q))
x)
(setf (qtail q) x)
item))))
(defun get-queue (q)
(prog1
(car (qhead q))
(setf (qtail q) (qhead q))
(setf (qhead q) (cdr (qhead q)))))
(defun remove-queue (item q)
(let ((qh (qhead q))
(qt (qtail q)))
(cond ((eq qh qt)
(cond ((eq item (car qh))
(setf (qhead q) ())
(setf (qtail q) ())
item)))
((eq (car qh) item)
(setf (qhead q)(cdr qh))
(setf (cdr qt) (cdr qh))
item)
(t
(do ((x qh (cdr x))
(y (cdr qh) (cdr y)))
((eq y qt)
(cond ((eq item (car y))
(setf (qtail q)
x)
(setf (cdr x)
(qhead q))
item)))
(cond ((eq item (car y))
(setf (cdr x)
(cdr y))
(return item))))))))
(defmacro tab ()
`(tyo #o9))
(defun m-flush-top-arg-stack ()
(pop *arg-stack*))
(defmacro copy (l)
`(mapcar #'(lambda (x) x) ,l))
(defmacro copy-environment (l)
`(mapcar #'(lambda (x) (cons (car x) (cdr x))) ,l))
;;; Defstructs
(defstruct (machine
(conc-name machine-))
(number 0)
(list ()) ;jobs to run
(processors ()))
(defstruct (processor
(conc-name processor-))
(queue-length 0)
(job-queue (make-queue)))
(defstruct (value-dest
(conc-name value-dest-))
(type 'processor)
(destination ()))
;;; Job-active can have these meanings:
;;; alive = running
;;; ready = ready to run
;;; dead = flushable
;;; wait = waiting for an event
;;; locked = unkillable
;;; suicidal= kill on unlock
(defstruct job
(arg-stack ())
(pc-stack ())
(evarg-stack ())
(environment ())
(valuep 'tail-recursive)
(closure-expression ())
(catch-thread ())
(job-waiter 'm-null-wait) ;function that decides when waiting is over
(job-values ()) ;values come here
(job-list ()) ;a list of jobs to substitute for
;this one when this one dies!
(job-expression ()) ;expression this job is computing
(job-dest-id ()) ;identification for the return message
(job-value-dest ()) ;destination of the value
; see above
(job-active 'dead))) ;values are dead, alive, wait
(defmacro copy-job (job)
`(let ((job ,job))
(make-job
arg-stack (arg-stack job)
pc-stack (pc-stack job)
evarg-stack (evarg-stack job)
environment (environment job)
valuep (valuep job)
catch-thread (catch-thread job)
closure-expression (closure-expression job)
job-waiter (job-waiter job)
job-values (job-values job)
job-list (job-list job)
job-expression (job-expression job)
job-dest-id (job-dest-id job)
job-value-dest (job-value-dest job)
job-active (job-active job))))
(defmacro restore-state (job)
`(let ((job ,job))
(setq *pc-stack* (pc-stack job)
*arg-stack* (arg-stack job)
*evarg-stack* (evarg-stack job)
*self* job
*valuep* (valuep job)
*environment* (environment job)
*catch-thread* (catch-thread job))))
(defmacro save-state (job)
`(let ((job ,job))
(setf (pc-stack job) *pc-stack*)
(setf (arg-stack job) *arg-stack*)
(setf (evarg-stack job) *evarg-stack*)
(setf (valuep job) *valuep*)
(setf (environment job) *environment*)
(setf (catch-thread job) *catch-thread*)))
(defmacro top (stack)
`(car ,stack))
(defmacro rfirst-n (n l)
`(do ((n ,n (1- n))
(a () ))
((zerop n) a)
(push (pop ,l) a)))
(defstruct (return-message
(conc-name return-message-))
(id ())
(contents ()))
(defmacro push-all (l s)
`(setf ,s (append ,l ,s)))
(defmacro find-message (id messages)
`(do ((mess ,messages (cdr mess))
(id ,id))
((null mess) ())
(cond ((eq (return-message-id (car mess)) id)
(return (car mess))))))
(defstruct (job-closure
(conc-name job-closure-))
(processor ())
(argument-type 'normal) ;can be lazy
(lazy-cells ()) ;and, if so, here they are
(job ()))
(defmacro make-qclosure (args job-record)
`(list 'qclosure ,args ,job-record))
(defmacro qclosurep (x)
`(let ((x ,x))
(and (not (atom x))
(eq (car x) 'qclosure))))
(defmacro qclosure-args (x)
`(cadr ,x))
(defmacro qclosure-job-record (x)
`(caddr ,x))
(defun m-restore-valuep ()
(setq *valuep* (pop *pc-stack*)))
(defstruct (unwind-protect-waiter
(conc-name unwind-protect-waiter-))
(valid ()))
(defstruct (unwind-protect-cleanup
(conc-name unwind-protect-cleanup-))
(environment ())
(job ())
(form ()))
(defstruct
(catch-record
(conc-name catch-record-))
(tag ())
(jobs ())
(job ())
(cleanups ())
(evarg-stack ())
(arg-stack ())
(pc-stack ())
(valuep ())
(catch-thread ())
(job-list ())
(job-values ())
(environment ()))
(defmacro m-push (a l)
`(setf ,l (cons ,a ,l)))
(defmacro m-pop (l)
`(prog1
(car ,l)
(setf ,l (cdr ,l))))
;;; This kills process closures, flushes them from the catch-thread, and
;;; deletes the unwind-protect cleanups
(defun kill-all-closure-jobs (l)
(do ((l l (cdr l)))
((null l)
t)
(do ((th *catch-thread* (catch-record-catch-thread th)))
((null th) t)
(setf (catch-record-jobs th)
(delq (job-closure-job (car l))
(catch-record-jobs th))))
(let ((processor (job-closure-processor (car l))))
(cond (processor
(let ((job (job-closure-job (car l))))
(caseq (job-active job)
((alive wait dead)
(remove-queue job
(processor-job-queue
processor)))
(locked (setf (job-active job) 'suicidal))
(suicidal)
(t ()))))))))
(defmacro catch-restore-state (job record)
`(let ((job ,job)
(record ,record))
(setf (pc-stack job) (catch-record-pc-stack record))
(setf (arg-stack job) (catch-record-arg-stack record))
(setf (evarg-stack job) (catch-record-evarg-stack record))
(setf (valuep job) (catch-record-valuep record))
(setf (environment job) (catch-record-environment record))
(setf (job-list job)(catch-record-job-list record))
(setf (job-values job)(catch-record-job-values record))
))
(defmacro catch-restore-self (record)
`(let ((record ,record))
(setq *pc-stack* (catch-record-pc-stack record))
(setq *arg-stack* (catch-record-arg-stack record))
(setq *evarg-stack* (catch-record-evarg-stack record))
(setq *valuep* (catch-record-valuep record))
(setq *environment* (catch-record-environment record))
(setf (job-list *self*) (catch-record-job-list record))
(setf (job-values *self*) (catch-record-job-values record))
))
(defmacro m-add-job-list (job item)
`(do ((job ,job (job-list job)))
((null (job-list job))
(setf (job-list job) ,item))) )
(defmacro make-lazy-cell ()
`(list 'lazy 'empty ()))
(defmacro lazy-cellp (x)
`(eq (car ,x) 'lazy))
(defmacro lazy-cell-fullp (x)
`(eq (cadr ,x) 'full))
(defmacro lazy-cell-full (x)
`(cadr ,x))
(defmacro lazy-cell-value (x)
`(caddr ,x))
;;; Deletes everything from l that is in d, destructively
(defun delete-em-all (d l)
(do ((x l (cdr x)))
((not (memq (car x) d)) (setq l x)))
(do ((p1 l (cdr p1))
(p2 (cdr l) (cdr p2)))
((null p2) l)
(cond ((memq (car p2) d)
(setf (cdr p1) (cdr p2))
(setq p2 (cdr p2))))))
;;; Metering
(defstruct (meter
(conc-name meter-))
(processes 0)
(scheduled-processes 0)
(processors 0)
(wait-cycles 0)
(active-cycles 0)
(read-conflicts 0)
(write-conflicts 0)
(multicycles 0))
(defmacro incf (slot)
`(setf ,slot (1+ ,slot)))
(defmacro decf (slot)
`(setf ,slot (1- ,slot)))
(defun report ()
(cond (*graphp*
(setq *points*
(nconc *points*
`((,(cond (*xfun*
(funcall *xfun*))
(t (meter-processors *meter*)))
,(cond (*yfun*
(funcall *yfun*))
(t (meter-multicycles *meter*)))))))))
(cond (*silence*)
(t (terpri)
(princ "Number of Processors:")
(tab)
(princ (meter-processors *meter*))
(terpri)
(princ "Processes Created:")
(tab)
(princ (meter-processes *meter*))
(terpri)
(princ "Processes Scheduled:")
(tab)
(princ (meter-scheduled-processes *meter*))
(terpri)
(princ "Read Conflicts:")
(tab)(tab)
(princ (meter-read-conflicts *meter*))
(terpri)
(princ "Write Conflicts:")
(tab)
(princ (meter-write-conflicts *meter*))
(terpri)
(princ "Wait Cycles:")
(tab)(tab)
(princ (meter-wait-cycles *meter*))
(terpri)
(princ "Active Cycles:")
(tab)(tab)
(princ (meter-active-cycles *meter*))
(terpri)
(princ "Multiprocessor Steps:")
(tab)
(princ (meter-multicycles *meter*))
(terpri))))
(defun recent-var-memq (var l)
(do ((q *recent-vars* (cdr q)))
((null q) ())
(cond ((and (eq (car (car l))
var)
(not (eq (cdr (car l))
*self*)))
(return l)))))
;;; Process Loop
;;; Steps once for each processor
(defun multi-process (machine)
(cond ((machine-list machine)
(multi-schedule (machine-list machine)
(machine-processors machine))
(setf (machine-list machine) ())))
(do ((all-wait t)
(all-dead t)
(i 2 (1- i)))
((or (null all-wait)
(zerop i))
all-dead)
(do ((pr (machine-processors machine) (cdr pr))
; (n 1 (1+ n))
(processor ()))
((null pr))
; (print `(processor ,n))
(setq processor (car pr))
(let* ((queue (processor-job-queue processor))
(last (queue-tail queue))
(job (get-queue queue)))
(do ((awakened ()))
(())
(cond (job
(caseq (process-job job)
(dead
(setf (processor-queue-length processor)
(1- (processor-queue-length processor)))
(remove-queue job (processor-job-queue processor))
(cond ((eq job last) ;we just tried the last job
(setq all-dead
(and all-dead
(not awakened)))
(return all-dead))
(t (setq job (get-queue queue)))))
(awakened
(setq awakened t)
(setf (processor-queue-length processor)
(1- (processor-queue-length processor)))
(remove-queue job (processor-job-queue processor))
(cond ((eq job last) ;we just tried the last job
(setq all-wait ())
(setq all-dead ())
(return ())) ;all dead
(t
(setq job
(get-queue queue)))))
(wait
(cond ((eq job last)
(setq all-dead
(and all-dead
(not awakened)))
(return (not awakened)))
(t
(setq job
(get-queue queue)))))
((alive locked suicidal)
(setq all-dead () all-wait ())
(return ())))) ;something is alive
(t (return t)))))))) ;all dead
;;; Returns ALIVE if JOB is alive
(defun process-job (job)
(prog2
(restore-state job)
(let ((state (job-active job)))
(caseq state
((alive locked suicidal)
(incf (meter-active-cycles *meter*))
(funcall (pop *pc-stack*))
(cond ((null *pc-stack*) ;dead
(let ((jvds (job-value-dest job))
(all-empty t))
(setf (job-value-dest)
(mapcan
#'(lambda (jvd)
(cond
((eq (value-dest-type (car jvd)) 'empty)
(ncons jvd))
(t (return-message
jvd
(top *arg-stack*)
(job-dest-id job))
(setq all-empty ())
())))))
(cond (all-empty
(push (job-value-dest job) *arg-stack*)
(setf (job-active job) 'wait)
(setf (job-waiter job) 'm-wait-value-dest)
'wait)
(t
(let ((jl (job-list job)))
(cond (jl
(setf (job-list job) (job-list jl))
(setf (job-dest-id job) (job-dest-id jl))
(setf (job-value-dest job) (job-value-dest jl))
(restore-state jl)
(setf (job-active job) 'alive)
'alive)
(t (cond ((closure-expression job)
(setf (job-active job) 'ready))
(t (setf (job-active job) 'dead)))
'awakened)))))))
(t state))) ;alive
(wait
(cond ((funcall (job-waiter job))
(incf (meter-active-cycles *meter*))
(setf (job-active job) 'alive)
(cond ((null *pc-stack*) ;dead
(cond ((job-value-dest job)
(mapc
#'(lambda (jvd)
(return-message
jvd
(top *arg-stack*)
(job-dest-id job)))
(job-value-dest job))))
(let ((jl (job-list job)))
(cond (jl
(setf (job-list job) (job-list jl))
(setf (job-dest-id job) (job-dest-id jl))
(setf (job-value-dest job) (job-value-dest jl))
(restore-state jl)
(setf (job-active job) 'alive)
'alive)
(t (cond ((closure-expression job)
(setf (job-active job) 'ready))
(t (setf (job-active job) 'dead)))
'awakened))))
(t 'alive))) ;alive
(t
(incf (meter-wait-cycles *meter*))
'wait))) ;alive
(dead 'dead)
(t (error "Process-job error" (closure-expression job)))))
(save-state job))))))
(defun return-message (dest value expression)
(caseq (value-dest-type dest)
(processor
(let ((job (value-dest-destination dest)))
(setf (job-values job)
(nconc (job-values job)
(ncons (make-return-message
id expression
contents value))))))
(lazy-cell
(let ((cell (value-dest-destination dest)))
(setf (lazy-cell-value cell) value)
(setf (lazy-cell-full cell) 'full)))
(t (error "Bad Return Message Type"))))
(defun multi-schedule (queue processors)
(do ((l queue (cdr l)))
((null l) ())
(multi-schedule-one (car l) () processors)))
(defun multi-schedule-one (job record processors)
(incf (meter-scheduled-processes *meter*))
(let ((best
(car processors))
(len (processor-queue-length (car processors))))
(do ((pr (cdr processors) (cdr pr)))
((null pr)
(setf (job-active job) 'alive)
(add-queue job
(processor-job-queue best))
(setf (processor-queue-length best)
(1+ (processor-queue-length best)))
(cond (record
(setf
(job-closure-processor record)
best))))
(cond ((< (processor-queue-length (car pr))
len)
(setq best (car pr)
len (processor-queue-length (car pr))))))))
(defun run (machine)
(do ((dead (multi-process machine)
(multi-process machine))
(n *variable-conflict-window* (1- n))
(*time* 1 (1+ *time*)))
(dead (setf (meter-multicycles *meter*) *time*) t)
(setf (meter-multicycles *meter*) *time*)
(cond ((zerop n) (setq *recent-vars* ())))
))
(defun now ()
*time*)
;;; Environment Stuff
(defun m-assign (var val)
(do ((l *environment* (cdr l)))
((null l)
(push `(,var . ,*self*) *recent-vars*)
(set var val))
(cond ((eq (caar l)
var)
(cond ((recent-var-memq (car l) *recent-vars*)
(incf (meter-write-conflicts *meter*))
(push (car l) *pc-stack*)
(push-all `(m-delay ,*read-time*) *pc-stack*)
(push 'm-assign-2 *pc-stack*)
(push val *arg-stack*)
(return ()))
(t
(push `(, (car l) . ,*self*) *recent-vars*)
(setf (cdr (car l))
val)
(return val)))))))
(defun m-lookup-1 (var)
(do ((l *environment* (cdr l)))
((null l)
(cond ((boundp var)
(symeval var))))
(cond ((eq (caar l)
var)
(return (cdr (car l)))))))
(defun m-add-env (var val)
(push `(,var . ,val) *environment*))
(defun m-add-env-1 (pairs)
(setq *environment*
(append pairs *environment*)))
(defun m-symeval (var)
(cond ((recent-var-memq var *recent-vars*)
(incf (meter-read-conflicts *meter*))
(push 'm-symeval-1 *pc-stack*)
(push-all `(m-delay ,*read-time*) *pc-stack*))
(t
(push `(,var . ,*self*) *recent-vars*)
(setf (top *arg-stack*)
(symeval var)))))
(defun m-symeval-1 ()
(setf (top *arg-stack*)
(symeval (top *arg-stack*))))
(defun m-symeval-2 ()
(setf (top *arg-stack*)
(cdr (top *arg-stack*))))
;;; Simple Interpreter M-EVAL
(defun m-eval ()
(let ((expr (top *arg-stack*)))
; (print `(evaling ,expr))
(cond ((numberp expr))
((null expr))
((eq expr t))
((atom expr)
(cond ((zerop *read-time*)
(setf (top *arg-stack*) (m-lookup-1 (top *arg-stack*))))
(t
(let ((var (top *arg-stack*)))
(do ((l *environment* (cdr l)))
((null l)
(m-symeval var))
(cond ((eq (caar l)
var)
(cond ((recent-var-memq (car l) *recent-vars*)
(incf (meter-read-conflicts *meter*))
(push 'm-symeval-2 *pc-stack*)
(push-all `(m-delay ,*read-time*) *pc-stack*)
(setf (top *arg-stack*) (car l))
(return ())
)
(t (setf (top *arg-stack*) (cdr (car l)))
(push
`(,(car l) . ,*self*)
*recent-vars*)
(return ())))))))))
(let ((val (top *arg-stack*)))
(cond ((atom val))
((numberp val))
((lazy-cellp val)
(cond ((lazy-cell-fullp val)
(setf (top *arg-stack*)
(lazy-cell-value val)))
(t (m-wait-for-lazy-value)))))))
((atom (car expr))
(caseq (car expr)
(quote (setf (top *arg-stack*)
(cadr expr)))
((closure qclosure))
(setq (push (cadr expr) *pc-stack*)
(push 'm-evsetq *pc-stack*)
(push 'm-eval *pc-stack*)
(setf (top *arg-stack*) (caddr expr)))
(lambda
(setf (top *arg-stack*)
`(closure ,expr ,*environment*)))
(qlambda
(push *valuep* *pc-stack*)
(push 'm-restore-valuep *pc-stack*)
(setq *valuep* 'argument)
(setf (top *arg-stack*) (cadr expr))
(push expr *pc-stack*)
(push 'm-qlambda *pc-stack*)
(push 'm-eval *pc-stack*))
(cond
(push *valuep* *pc-stack*)
(push (cdr expr) *pc-stack*)
(push 'm-evcond *pc-stack*)
(setq *valuep* 'argument)
(setf (top *arg-stack*) (car (cadr expr)))
(push 'm-eval *pc-stack*))
(progn
(push *valuep* *pc-stack*)
; (push 'm-restore-valuep *pc-stack*)
(pop *arg-stack*)
(setq *valuep* ())
(push expr *pc-stack*)
(push 'm-evprogn *pc-stack*))
(or
(push *valuep* *pc-stack*)
(push (cddr expr) *pc-stack*)
(push 'm-evor *pc-stack*)
(setf (top *arg-stack*) (cadr expr))
(setq *valuep* 'argument)
(push 'm-eval *pc-stack*))
(and
(push *valuep* *pc-stack*)
(push (cddr expr) *pc-stack*)
(push 'm-evand *pc-stack*)
(setf (top *arg-stack*) (cadr expr))
(setq *valuep* 'argument)
(push 'm-eval *pc-stack*))
(not
(push *valuep* *pc-stack*)
(push 'm-evnot *pc-stack*)
(push 'm-eval *pc-stack*)
(setq *valuep* 'argument)
(setf (top *arg-stack*) (cadr expr)))
(do
(push *environment* *pc-stack*)
(push 'm-restore-env *pc-stack*)
(push 'm-restore-catch-thread-1 *pc-stack*)
(let ((*pc-stack* *pc-stack*)
(*arg-stack* *arg-stack*))
(push 'internal-do-tag *arg-stack*)
(push () *pc-stack*)
(m-catch))
(pop *arg-stack*)
(let ((vars
(mapcar #'car (cadr expr))))
(push `(,vars
,(mapcar #'caddr (cadr expr))
,(car (caddr expr))
,(m-prognify (cdr (caddr expr)))
,(m-prognify (cdddr expr))
,*valuep*)
*pc-stack*)
(m-do-step-1 (mapcar #'cadr (cadr expr)))
))
(return
(push 'm-throw *pc-stack*)
(push 'internal-do-tag *evarg-stack*)
(setf (top *arg-stack*) (cadr expr))
(push 'm-eval *pc-stack*))
(catch
(push 'm-restore-catch-thread-1 *pc-stack*)
(push 'm-restore-catch-thread *pc-stack*)
(push 'm-do-unwind-protect-cleanups *pc-stack*)
(push 'm-eval *pc-stack*)
(setf (top *arg-stack*) (caddr expr))
(push 'm-catch *pc-stack*)
(push (cadr expr) *arg-stack*)
(push 'm-eval *pc-stack*))
(qcatch
(push 'm-restore-catch-thread-1 *pc-stack*)
(push 'm-restore-catch-thread *pc-stack*)
(push 'm-do-unwind-protect-cleanups *pc-stack*)
(push 'm-qcatch *pc-stack*)
(push 'm-eval *pc-stack*)
(setf (top *arg-stack*) (caddr expr))
(push 'm-catch *pc-stack*)
(push (cadr expr) *arg-stack*)
(push 'm-eval *pc-stack*))
(throw
(push 'm-throw *pc-stack*)
(setf (top *arg-stack*) (caddr expr))
(push 'm-eval *pc-stack*)
(push 'm-stash-arg *pc-stack*)
(push (cadr expr) *arg-stack*)
(push 'm-eval *pc-stack*))
(unwind-protect
(push (job-active *self*) *pc-stack*)
(push 'm-restore-lock *pc-stack*)
(push (caddr expr) *arg-stack*)
(push 'm-eval *pc-stack*)
(push 'm-set-lock *pc-stack*)
(push 'm-flush-top-arg-stack *pc-stack*)
(push (cadr expr) *arg-stack*)
(setq *valuep* 'argument)
(push 'm-eval *pc-stack*)
(cond (*catch-thread*
(m-add-unwind-protects
*self* *environment*
(caddr expr) *catch-thread*))))
(funcall
(push *environment* *pc-stack*)
(push 'm-restore-env *pc-stack*)
(pop *arg-stack*)
(push (cddr expr) *pc-stack*)
(push 'm-funcall *pc-stack*)
(push (cadr expr) *arg-stack*)
(push 'm-eval *pc-stack*))
(labels
(m-eval-labels expr))
(caseq
(setf (top *arg-stack*)
(m-expand-caseq (top *arg-stack*)))
(push 'm-eval *pc-stack*))
(t
(let ((m
(get (car expr) 'macro))
(ovaluep *valuep*))
(cond (m
(let ((form (funcall m expr)))
(rplaca expr (car form))
(rplacd expr (cdr form))
(setf (top *arg-stack*)
expr))
(push 'm-eval *pc-stack*))
(t
(pop *arg-stack*)
(cond
((getl (car expr) '(expr subr lsubr))
(push (car expr) *pc-stack*)
(push (length (cdr expr)) *pc-stack*)
(push 'm-lisp-call *pc-stack*))
(t
(cond ((eq ovaluep 'argument)
(push *environment* *pc-stack*)
(push 'm-restore-env *pc-stack*)))
(push (car expr) *pc-stack*)
(push 'm-apply *pc-stack*)))
(push *valuep* *pc-stack*)
(push 'm-restore-valuep *pc-stack*)
(setq *valuep* 'argument)
(do ((l (reverse (cdr expr)) (cdr l)))
((null l) ())
(push 'm-stash-arg *pc-stack*)
(push 'm-eval *pc-stack*)
(push (car l) *arg-stack*))))))))
(t
(caseq (caar expr)
((lambda closure)
(push *environment* *pc-stack*)
(push 'm-restore-env *pc-stack*)
(push (car expr) *pc-stack*)
(push 'm-apply *pc-stack*)
(pop *arg-stack*)
(push *valuep* *pc-stack*)
(push 'm-restore-valuep *pc-stack*)
(setq *valuep* 'argument)
(do ((l (reverse (cdr expr)) (cdr l)))
((null l) ())
(push 'm-stash-arg *pc-stack*)
(push 'm-eval *pc-stack*)
(push (car l) *arg-stack*)))
((qlambda qclosure)
(push expr *pc-stack*)
(push 'm-qlambda-apply *pc-stack*)
(push *valuep* *pc-stack*)
(push 'm-restore-valuep *pc-stack*)
(setq *valuep* 'argument)
(push (cadr (car expr)) *arg-stack*)
(push 'm-eval *pc-stack*)))))))
(defun m-prognify (form)
(cond ((null (cdr form)) (car form))
(t `(progn . ,form))))
(defun m-funcall ()
(let ((expr (top *pc-stack*)))
(setf (top *pc-stack*) (pop *arg-stack*))
(push 'm-apply *pc-stack*)
(do ((l (reverse expr) (cdr l)))
((null l)
())
(push 'm-stash-arg *pc-stack*)
(push 'm-eval *pc-stack*)
(push (car l) *arg-stack*)) ))
(defun m-eval-labels (expr)
(let ((vars ())
(vals ()))
(push *valuep* *pc-stack*)
(push 'm-restore-valuep *pc-stack*)
(setq *valuep* 'argument)
(push *environment* *pc-stack*)
(push 'm-restore-env *pc-stack*)
(do ((l (cadr expr) (cdr l))
(var ())(val ()))
((null l) ())
(setq var (caar l) val (cadar l))
(m-add-env var ())
(push var vars)
(push val vals))
(push `(labels ,(reverse vars) . ,(cddr expr)) *pc-stack*)
(push 'm-apply *pc-stack*)
(pop *arg-stack*)
(do ((l vals (cdr l)))
((null l) ())
(push 'm-stash-arg *pc-stack*)
(push 'm-eval *pc-stack*)
(push (car l) *arg-stack*))))
(defun m-qlambda ()
(let ((val (top *arg-stack*)))
(cond
((eq val 'lazy)
(let ((x (top *pc-stack*)))
(setf (top *pc-stack*) 'm-flush-top-arg-stack)
(push x *pc-stack*))
(setq *valuep* ())
(setf (top *arg-stack*)(pop *pc-stack*))
(let ((cells
(m-lazy-evqlambda)))
(push (top *arg-stack*) *pc-stack*)
(push 'm-apply *pc-stack*)
(push-all cells *evarg-stack*)
))
(val
(setf (top *arg-stack*) (pop *pc-stack*))
(m-evqlambda))
(t
(setf (top *arg-stack*)
`(closure (lambda .,(cddr (pop *pc-stack*)))
,*environment*))))))
(defun m-restore-lock ()
(caseq (job-active *self*)
(suicidal (setf (job-active *self*) 'dead))
(t (setf (job-active *self*) (pop *pc-stack*)))))
(defun m-set-lock ()
(setf (job-active *self*) 'locked))
(defun m-expand-caseq (form)
(let ((var (gensym)))
`((lambda (,var)
(cond . ,(mapcar
#'(lambda (q)
(cond
((eq (car q) 't)
`(t .,(cdr q)))
((or (atom (car q))
(numberp (car q)))
`((equal ,var (quote ,(car q)))
. ,(cdr q)))
(t
`((member ,var (quote ,(car q)))
. ,(cdr q)))))
(cddr form))))
,(cadr form))))
;;; Simple Interpreter M-APPLY
(defun m-apply ()
(let ((new-valuep *valuep*))
(let ((fun (pop *pc-stack*)))
(let ((val
(cond ((atom fun)
(setq new-valuep 'tail-recursive)
(let ((val
(m-lookup-1 fun)))
(prog1
(cond (val)
(t
(setq *environment* ())
(get fun 'm-expr))))))
(t fun))))
(cond ((lazy-cellp val)
(cond ((lazy-cell-fullp val)
(setq val
(lazy-cell-value val)))
(t (push new-valuep *pc-stack*)
(push fun *pc-stack*)
(push val *arg-stack*)
(push 'm-apply2 *pc-stack*)
(m-wait-for-lazy-value))))
((eq (car val) 'qlambda)
(push *valuep* *pc-stack*)
(push fun *pc-stack*)
(push 'm-apply2 *pc-stack*)
(push (cadr val) *arg-stack*)
(push val *pc-stack*)
(push 'm-qlambda *pc-stack*)
(push 'm-eval *pc-stack*))
(t (m-apply1 val fun new-valuep)))))))
(defun m-apply2 ()
(m-apply1 (pop *arg-stack*) (pop *pc-stack*) (pop *pc-stack*)))
(defun m-apply1 (val fun new-valuep)
(let ((args ())
(labels ())
(qclosure-state ())
(job *self*)
(running-lazy-closurep ())
(lazy-closurep ())
(new-lazy-closurep ())
(cells ())
(body ()))
(caseq (car val)
(lambda
(setq args (cadr val)
body (cddr val)))
(labels
(setq labels t)
(setq args (cadr val)
body (cddr val)))
(qclosure
(let* ((closure-job (qclosure-job-record val))
(job1
(job-closure-job closure-job))
(argument-type (job-closure-argument-type closure-job)))
(setq qclosure-state (job-active job1))
(cond
((eq qclosure-state 'ready)
(cond
((eq argument-type 'normal)
(let ((record
(qclosure-job-record val)))
(multi-schedule-one
job1 record
(machine-processors *machine*))))
((eq argument-type 'new-lazy)
(setq lazy-closurep t)
(setq new-lazy-closurep t)
(setf (job-closure-argument-type closure-job)
'lazy)
(let ((record
(qclosure-job-record val)))
(multi-schedule-one
job1 record
(machine-processors *machine*))))
(t
(setq cells (job-closure-lazy-cells closure-job))
(setq running-lazy-closurep t)
(setf (job-closure-argument-type closure-job)
'normal))))
((eq (job-closure-argument-type closure-job)
'lazy)
(setq lazy-closurep t)
(setq cells (job-closure-lazy-cells closure-job))
(setq running-lazy-closurep t)
(setf (job-closure-argument-type closure-job)
'normal))
(t (let ((job2
(copy-job job1)))
(setf (job-list job2) ())
(m-add-job-list job1 job2)
(setq job1 job2))))
(setq job job1
args (cadr (cadr (closure-expression job1)))
body (cddr (cadr (closure-expression job1))))
(cond ((eq *valuep* 'tail-recursive)
(setf (job-value-dest *self*) ())))
(cond (lazy-closurep
(cond (running-lazy-closurep
(cond ((not (eq *valuep* 'tail-recursive))
(setf (job-active *self*) 'wait)
(setf (job-waiter *self*) 'm-wait-closure)
(setf (job-dest-id job1) job1)
(let ((jvd (job-value-dest job1)))
(cond ((null (cdr jvd))
(setf (value-dest-type jvd)
'processor)
(setf (value-dest-destination
jvd)
*self*))
(t (m-push
(make-value-dest
type 'processor
destination *self*)
(job-value-dest job1)))))
(push job1 *pc-stack*))))
(new-lazy-closurep
(push-all
(caddr (closure-expression job1))
(environment job1))
(push 'no-value *arg-stack*))))
(t (push-all
(caddr (closure-expression job1))
(environment job1))
(cond
((null *valuep*)
(push 'no-value *arg-stack*)
(setf (job-value-dest job1) ()))
((eq *valuep* 'tail-recursive))
(t (setf (job-active *self*) 'wait)
(setf (job-waiter *self*) 'm-wait-closure)
(setf (job-dest-id job1) job1)
(setf (job-value-dest job1)
(make-value-dest
type 'processor
destination *self*))
(push job1 *pc-stack*)))))))
(closure
(cond ((eq (caddr val) *environment*))
(t (push *environment* *pc-stack*)
(push 'm-restore-env *pc-stack*)
(setq *environment* (caddr val))))
(setq args (cadr (cadr val))
body (cddr (cadr val)))
(cadr val))
(t (let ((*function* fun))
(error "Bad Function" fun))))
(do ((var (reverse args) (cdr var))
(l ()))
((null var)
(setq *valuep* new-valuep)
(cond ((eq job *self*)
(cond (labels
(mapc #'(lambda (x)
(m-assign (car x) (cdr x)))
l))
(t (push-all l *environment*)))
(cond ((null (cdr body))
(push (car body) *arg-stack*)
(push 'm-eval *pc-stack*))
(t
(push *valuep* *pc-stack*)
(push `(progn . ,body) *pc-stack*)
(push 'm-evprogn *pc-stack*))))
(running-lazy-closurep
(mapc #'(lambda (cell value)
(setf (lazy-cell-full cell) 'full)
(setf (lazy-cell-value cell) (cdr value)))
cells l))
(t
(push-all l (environment job))
(cond ((null (cdr body))
(setf (arg-stack job) (ncons (car body)))
(setf (pc-stack job) (ncons 'm-eval)))
(t (setf (pc-stack job) `(m-evprogn (progn . ,body)
,*valuep*))
(setf (arg-stack job) ())))
(cond ((not (zerop *process-creation-time*))
(m-push *process-creation-time* (pc-stack job))
(m-push 'm-delay (pc-stack job))))) )
)
(push `(,(car var) . ,(pop *evarg-stack*)) l))))
(defun m-lisp-call ()
(let ((vals (rfirst-n (pop *pc-stack*) *evarg-stack*)))
(push (apply (pop *pc-stack*) vals)
*arg-stack*) ))
(defun m-restore-env ()
(setq *environment* (pop *pc-stack*)))
(defun m-restore-catch-thread ()
(and *catch-thread*
(kill-all-closure-jobs
(catch-record-jobs *catch-thread*))))
(defun m-restore-catch-thread-1 ()
(and *catch-thread*
(setq *catch-thread* (catch-record-catch-thread *catch-thread*))))
(defun m-stash-arg ()
(push (pop *arg-stack*) *evarg-stack*))
(defun m-sleep (n)
(push n *pc-stack*)
(push 'm-delay *pc-stack*))
(defun m-delay ()
(let ((n (top *pc-stack*)))
(cond ((zerop n)
(pop *pc-stack*))
(t (decf (top *pc-stack*))
(push 'm-delay *pc-stack*)))))
(defun m-add-catch-threads (rec th)
(do ((th th (catch-record-catch-thread th)))
((null th) t)
(m-push rec
(catch-record-jobs th))))
(defun m-add-unwind-protects (job environment form th)
(do ((th th (catch-record-catch-thread th)))
((null th) t)
(m-push (make-unwind-protect-cleanup
job job
environment (copy-environment environment)
form form)
(catch-record-cleanups th))))
;;; COND, OR, AND, NOT
(defun m-evcond ()
(let ((val (top *arg-stack*)))
(cond (val
(let ((arm (car (pop *pc-stack*))))
(setf *valuep* (pop *pc-stack*))
(cond ((cdr arm)
(pop *arg-stack*)
(cond ((null (cddr arm))
(push (cadr arm) *arg-stack*)
(push 'm-eval *pc-stack*))
(t
(push *valuep* *pc-stack*)
(push `(progn . ,(cdr arm)) *pc-stack*)
(push 'm-evprogn *pc-stack*)))))))
(t (let ((arms (pop *pc-stack*)))
(cond (arms
(pop *arg-stack*)
(push (cdr arms) *pc-stack*)
(push 'm-evcond *pc-stack*)
(push (car (cadr arms)) *arg-stack*)
(push 'm-eval *pc-stack*))
(t (setf *valuep* (pop *pc-stack*)))))))))
(defun m-evor ()
(let ((val (top *arg-stack*)))
(cond (val
(setf *valuep* (pop *pc-stack*))
(pop *pc-stack*))
(t (let ((arms (pop *pc-stack*)))
(cond (arms
(pop *arg-stack*)
(push (cdr arms) *pc-stack*)
(push 'm-evor *pc-stack*)
(push (car arms) *arg-stack*)
(push 'm-eval *pc-stack*))
(t (setf *valuep* (pop *pc-stack*)))))))))
(defun m-evand ()
(let ((val (top *arg-stack*)))
(cond ((not val)
(setf *valuep* (pop *pc-stack*))
(pop *pc-stack*))
(t (let ((arms (pop *pc-stack*)))
(cond (arms
(pop *arg-stack*)
(push (cdr arms) *pc-stack*)
(push 'm-evand *pc-stack*)
(push (car arms) *arg-stack*)
(push 'm-eval *pc-stack*))
(t (setf *valuep* (pop *pc-stack*)))))))))
(defun m-evnot ()
(setf *valuep* (pop *pc-stack*))
(setf (top *arg-stack*) (not (top *arg-stack*))))
;;; PROGN
(defun m-evprogn ()
(let ((form (pop *pc-stack*)))
(cond ((cddr form)
(setq *valuep* ())
(push `(progn . ,(cddr form)) *pc-stack*)
(push 'm-evprogn-1 *pc-stack*))
(t (setq *valuep* (pop *pc-stack*))))
(push (cadr form) *arg-stack*)
(push 'm-eval *pc-stack*)
)))
(defun m-evprogn-1 ()
(pop *arg-stack*)
(let ((form (pop *pc-stack*)))
(cond ((cddr form)
(setq *valuep* ())
(push `(progn . ,(cddr form)) *pc-stack*)
(push 'm-evprogn-1 *pc-stack*))
(t (setq *valuep* (pop *pc-stack*))))
(push (cadr form) *arg-stack*)
(push 'm-eval *pc-stack*)
)))
;;; SETQ
(defun m-evsetq ()
(cond ((zerop *write-time*)
(m-assign
(pop *pc-stack*)
(top *arg-stack*)))
(t (cond ((recent-var-memq (top *pc-stack*)
*recent-vars*)
(incf (meter-write-conflicts *meter*))
(push 'm-assign-1 *pc-stack*)
(push-all `(m-delay ,*write-time*)
*pc-stack*))
(t
(m-assign
(pop *pc-stack*)
(top *arg-stack*)))))))
(defun m-assign-1 ()
(m-assign
(pop *pc-stack*)
(top *arg-stack*)))
(defun m-assign-2 ()
(setf (cdr (pop *pc-stack*)) (top *arg-stack*)))
;;; QLAMBDA
(defun m-evqlambda ()
(incf (meter-processes *meter*))
(let ((expr (top *arg-stack*))
(env (copy *environment*)))
(let ((expression `(closure ,expr ,env))
(body (m-prognify (cdddr expr)))
(cexpression `(closure (lambda ,(caddr expr)
.,(cdddr expr))
,env)))
(let ((record
(make-job-closure
job
(make-job
closure-expression cexpression
job-expression expression
job-dest-id expr
catch-thread *catch-thread*
arg-stack (ncons body)
pc-stack (ncons 'm-eval)
job-waiter 'm-closure-waiter
job-active 'ready))))
(setf (top *arg-stack*)
(make-qclosure
(caddr (top *arg-stack*))
record))
(cond (*catch-thread*
(m-add-catch-threads
record *catch-thread*)
record)
)))))
(defun m-lazy-evqlambda ()
(incf (meter-processes *meter*))
(let ((expr (top *arg-stack*))
(env (copy-environment *environment*)))
(let ((expression `(closure ,expr ,env))
(body (m-prognify (cdddr expr)))
(cells (mapcar #'(lambda (())
(make-lazy-cell))
(caddr expr)))
(cexpression `(closure (lambda ,(caddr expr)
.,(cdddr expr))
,env)))
(let ((record
(make-job-closure
argument-type 'new-lazy
lazy-cells cells
job
(make-job
closure-expression cexpression
job-expression expression
job-dest-id expr
catch-thread *catch-thread*
arg-stack (ncons body)
job-value-dest
(ncons (make-value-dest
type 'empty))
pc-stack (ncons 'm-eval)
job-waiter 'm-closure-waiter
job-active 'ready))))
(setf (top *arg-stack*)
(make-qclosure
(caddr (top *arg-stack*))
record))
(cond (*catch-thread*
(m-add-catch-threads
record *catch-thread*)
record)
)
cells))))
(defun m-qlambda-apply ()
(let ((form (pop *pc-stack*))
(multip (pop *arg-stack*)))
(cond (multip
(let ((destinations
(cond ((eq multip 'lazy)
(push 'm-restore-catch-thread *pc-stack*)
(let ((*pc-stack* *pc-stack*)
(*arg-stack* *arg-stack*))
(push (ncons ()) *arg-stack*)
(push () *pc-stack*)
(m-catch))
(mapcar #'(lambda (())
(make-value-dest
type 'lazy-cell
destination (make-lazy-cell)))
(cdr form)))
(t (mapcar #'(lambda (())
(make-value-dest
type 'processor
destination *self*))
(cdr form))))))
(mapc #'(lambda (x dest)
(incf (meter-processes *meter*))
(let ((cexpression
`(closure
(lambda ()
,x)
,*environment*)))
(let ((expression `(,cexpression)))
(let ((job
(make-job
job-expression
cexpression
closure-expression
cexpression
catch-thread *catch-thread*
arg-stack (ncons expression)
pc-stack
(cond
((not (zerop *process-creation-time*))
`(m-delay ,*process-creation-time* m-eval))
(t (ncons 'm-eval)))
job-dest-id x
job-value-dest (ncons dest)
job-active 'ready)))
(cond (*catch-thread*
(m-add-catch-threads
(make-job-closure job job)
*catch-thread*)))
(multi-schedule-one
job ()
(machine-processors *machine*))))))
(cdr form) destinations)
(cond ((eq multip 'lazy)
(push
`(lambda .,(cddr (car form)))
*pc-stack*)
(push 'm-apply *pc-stack*)
(push-all
(mapcar
#'(lambda (x)
(value-dest-destination x))
destinations)
*evarg-stack*))
(t (setf (job-active *self*) 'wait)
(setf (job-waiter *self*) 'm-wait-for-messages)
(push form *pc-stack*)))))
(t
(setf (top *arg-stack*)
`((lambda .,(cddr (car form))) .,(cdr form)))
(push 'm-eval *pc-stack*)))))
(defun m-wait-for-messages ()
(cond ((=
(length (cdr (top *pc-stack*)))
(length (job-values *self*)))
(let ((form (pop *arg-stack*))
(messages (job-values *self*))
(not-all-here ()))
(let ((args
(mapcar #'(lambda (x)
(let ((q (find-message x messages)))
(cond (q
(return-message-contents
q))
(t (setq not-all-here t)))))
(reverse (cdr form)))))
(cond (not-all-here ())
(t (push-all args *evarg-stack*)
(setf (top *pc-stack*)
`(lambda .,(cddr (car form))))
(push 'm-apply *pc-stack*)
(setf (job-values *self*)
(mapcan
#'(lambda (x)
(cond ((memq (return-message-id x)
(cdr form)) ())
(t `(,x)))) (job-values *self*)))
t)))))))
(defun m-wait-closure ()
(let ((messages (job-values *self*)))
(cond ((null messages) ())
(t (let* ((message-id (pop *pc-stack*))
(q (find-message message-id messages)))
(cond (q
(push (return-message-contents q) *arg-stack*)
(setf (job-values *self*)
(mapcan
#'(lambda (x)
(cond ((eq (return-message-id x)
message-id) ())
(t `(,x)))) (job-values *self*)))
t)))))))
(defun m-null-wait () ())
;;; Job closures run this to see if there is a message to process
(defun m-closure-waiter ()
(let ((messages (job-values *self*)))
(break m-closure-waiter t)
(cond ((null messages) ())
(t
(push *environment* *pc-stack*)
(push 'm-restore-env *pc-stack*)
(push (closure-expression *self*) *pc-stack*)
(push 'm-apply *pc-stack*)
(do ((messages (car messages) (cdr messages)))
((null messages) (m-pop (job-values *self*)))
(push 'm-stash-arg *pc-stack*)
(push (car messages) *arg-stack*)
(push 'm-eval *pc-stack*))
t))))
(defun m-qcatch-waiter ()
(do ((jobs
(catch-record-jobs *catch-thread*)
(cdr jobs)))
((null jobs)
t)
(cond ((memq
(job-active (job-closure-job (car jobs)))
'(alive wait locked suicidal))
(return ())))))
(defun m-wait-for-lazy-value ()
(setf (job-active *self*) 'wait)
(setf (job-waiter *self*) 'm-wait-for-lazy-cell))
(defun m-wait-for-lazy-cell ()
(cond ((lazy-cell-fullp (top *arg-stack*))
(setf (top *arg-stack*)
(lazy-cell-value (top *arg-stack*)))
t)))
(defun m-wait-value-dest ()
(cond ((not
(do ((jvd (top *arg-stack*) (cdr jvd)))
((null jvd) ())
(cond ((eq
(value-dest-type (car jvd))
'empty))
(return t)))
(pop *arg-stack*)
t)))
(defun suspend-process (p)
(cond ((and (not (atom p))
(eq 'qclosure (car p)))
(let ((job
(job-closure-job
(qclosure-job-record p))))
(m-push (job-active job) (pc-stack job))
(m-push (job-waiter job) (pc-stack job))
(setf (job-active job) 'wait)
(setf (job-waiter job) 'm-null-wait)
t))
(t (setf (job-active p) 'wait)
t)))
(defun resume-process (p)
(cond ((and (not (atom p))
(eq 'qclosure (car p)))
(let ((job
(job-closure-job
(qclosure-job-record p))))
(setf (job-waiter job) (m-pop (pc-stack job)))
(setf (job-active job) (m-pop (pc-stack job)))
t))))
(defun m-unwind-protect-signal-done ()
(setf (unwind-protect-waiter-valid (pop *pc-stack*)) t)
(setf (job-value-dest *self*) ()))
(defun m-unwind-protect-waiter ()
(let ((waits (top *pc-stack*)))
(setq waits
(mapcan #'(lambda (q)
(cond ((unwind-protect-waiter-valid q) ())
(t (ncons q))))
waits))
(cond ((null waits) (pop *pc-stack*) t)
(t (setf (top *pc-stack*) waits)
()))))
;;; CATCH/THROW
(defun m-catch ()
(let ((tag (pop *arg-stack*)))
(setq *valuep* 'argument)
(setq *catch-thread*
(make-catch-record
tag tag
job *self*
arg-stack *arg-stack*
pc-stack *pc-stack*
evarg-stack *evarg-stack*
environment *environment*
job-list (job-list *self*)
job-values (job-values *self*)
valuep *valuep*
catch-thread *catch-thread*))
))
(defun m-qcatch ()
(cond ((null (catch-record-jobs *catch-thread*)))
(t (setf (job-active *self*) 'wait)
(setf (job-waiter *self*) 'm-qcatch-waiter))))
(defun m-throw ()
(let ((tag (pop *evarg-stack*)))
(do ((th *catch-thread*
(catch-record-catch-thread th)))
((null th)
(let ((*tag* tag))
(error "No CATCH for this tag" tag)))
(cond ((eq tag (catch-record-tag th))
(let ((val (top *arg-stack*))
(job (catch-record-job th)))
(cond ((eq *self* job)
(catch-restore-self th)
(pop *pc-stack*)
(setf (top *arg-stack*) val))
(t
(catch-restore-state job th)
(m-pop (pc-stack job))
(setf (top (arg-stack job)) val)
(caseq (job-active *self*)
(locked
(setf (job-active *self*) 'suicidal))
(suicidal)
(t (setf (job-active *self*) 'dead)))
(caseq (job-active job)
((alive locked suicidal))
(t (setf (job-active job) 'alive)))))
(return t)))))))
(defun m-do-unwind-protect-cleanups ()
(do ((cleanups
(reverse (catch-record-cleanups *catch-thread*))
(cdr cleanups))
(jobs-seen ())
(job ())
(waiters ()))
((null cleanups)
(let ((cleanups (catch-record-cleanups *catch-thread*)))
(do ((th (catch-record-catch-thread *catch-thread*)
(catch-record-catch-thread th))
(cl ()))
((null th) t)
(setq cl (catch-record-cleanups th))
(setf (catch-record-cleanups th)
(delete-em-all cleanups cl))))
; (setq *catch-thread*
; (catch-record-catch-thread *catch-thread*))
(and *catch-thread*
(setf (catch-record-cleanups *catch-thread*) ()))
(cond (waiters
(setf (job-active *self*) 'wait)
(push waiters *pc-stack*)
(setf (job-waiter *self*) 'm-unwind-protect-waiter))))
----
(setq job (unwind-protect-cleanup-job (car cleanups)))
(push (make-unwind-protect-waiter) waiters)
(cond ((not (memq job jobs-seen))
(setf (job-active job) 'locked)
(push job jobs-seen)
(setf (pc-stack job) `(m-restore-lock ,(job-active job)))
(setf (arg-stack job) ())))
(push-all`(m-restore-env
,(unwind-protect-cleanup-environment (car cleanups))
m-eval m-unwind-protect-signal-done
,(car waiters) m-flush-top-arg-stack)
(pc-stack job))
(m-push (unwind-protect-cleanup-form (car cleanups))
(arg-stack job))
---
))
;;; DO
;;; On PC-STACK:
;;; ((<vars><steppers><test-form><result-form><body><old-valuep>) ...)
;;; On EVARG-STACK:
;;; (val1 val2...)
(defmacro do-vars (l)
`(car ,l))
(defmacro do-steppers (l)
`(cadr ,l))
(defmacro do-test-form (l)
`(caddr ,l))
(defmacro do-result-form (l)
`(cadddr ,l))
(defmacro do-body (l)
`(cadr (cdddr ,l)))
(defmacro do-valuep (l)
`(caddr (cdddr ,l)))
;;; m-do-assign-1 and m-do-step-1 are the versions of
;;; m-do-assign and m-do-step that are done at initialization
;;; time rather than increment time in the loop. It is so
;;; that (do ((l l (cdr l)))...) can work.
(defun m-do-assign ()
(mapc #'(lambda (var)
(m-assign var (pop *evarg-stack*)))
(do-vars (top *pc-stack*)))
(push (do-test-form (top *pc-stack*))
*arg-stack*)
(push 'm-do-test *pc-stack*)
(push 'm-eval *pc-stack*))
(defun m-do-assign-1 ()
(mapc #'(lambda (var)
(m-add-env var (pop *evarg-stack*)))
(do-vars (top *pc-stack*)))
(push (do-test-form (top *pc-stack*))
*arg-stack*)
(push 'm-do-test *pc-stack*)
(push 'm-eval *pc-stack*))
(defun m-do-test ()
(let ((val (top *arg-stack*)))
(cond (val
(cond ((do-result-form (top *pc-stack*))
(setf (top *arg-stack*)
(do-result-form (top *pc-stack*)))
(setq *valuep* (do-valuep (top *pc-stack*)))
(setf (top *pc-stack*) 'm-eval)
)
(t
(setf (top *arg-stack*) ())
(pop *pc-stack*))))
(t (let ((body
(do-body (top *pc-stack*)))
(steppers (do-steppers (top *pc-stack*))))
(pop *arg-stack*)
(m-do-step steppers)
(push 'm-flush-top-arg-stack *pc-stack*)
(push 'm-eval *pc-stack*)
(setq *valuep* ())
(push body *arg-stack*)
)))))
(defun m-do-step (l)
(push 'm-do-assign *pc-stack*)
(do ((l l (cdr l)))
((null l) t)
(push 'm-stash-arg *pc-stack*)
(push 'm-eval *pc-stack*)
(push (car l) *arg-stack*)))
(defun m-do-step-1 (l)
(push 'm-do-assign-1 *pc-stack*)
(do ((l l (cdr l)))
((null l) t)
(push 'm-stash-arg *pc-stack*)
(push 'm-eval *pc-stack*)
(push (car l) *arg-stack*)))
;;; Definitions
(defun m-defun fexpr (args)
(putprop (car args)
`(lambda ,(cadr args)
,(m-prognify (cddr args)))
'm-expr)
(car args))
(defun m-qdefun fexpr (args)
(putprop (car args)
`(qlambda ,(cadr args) ,(caddr args)
,(m-prognify (cdddr args)))
'm-expr)
(car args))
;;; Simple Allocation Routines
(defmacro memq-and-remove (x l)
`(cond ((eq ,x (car ,l))
(setq ,l (cdr ,l))
t)
(t (do ((l ,l (cdr l))
(next (cdr ,l) (cdr next)))
((null l) ())
(cond ((eq ,x (car next))
(setf (cdr l) (cdr next))
(return t)))))))
(defun allocate (n)
(let ((new (+ *number-of-processes* n)))
(cond ((< new *max-number-of-processes*)
(push *self* *allocate-stack*)
(setq *number-of-processes* new)
t))))
(defun de-allocate (n)
(and (memq-and-remove *self* *allocate-stack*)
(setq *number-of-processes* (max 0 (- *number-of-processes* n)))))
;;; Simple 1-dimensional array stuff
(defun aref (ar n)
(arraycall t ar n))
(defun aset (ar n v)
(store (arraycall t ar n) v))
(defun make-array (n)
(*array () t n))
(defun ā¤ (x y)
(not (< y x)))
(defun ā„ (x y)
(not (< x y)))
;;; Useful Macros for the Running System.
(eval-when (compile eval) (setq defmacro-for-compiling t))
(defmacro spawn (form)
`(funcall ,form))
(defmacro synch (form)
`((lambda (x) x) ,form))
(defmacro asynch (form)
`(progn ,form ()))
(eval-when (compile eval) (setq defmacro-for-compiling ()))
;;; Startup
(defun make-multi-processor (n)
(m-init-world)
(setq *machine*
(make-machine number n
processors
(do ((n n (1- n))
(pr () (push (make-processor) pr)))
((zerop n) pr))))
t)
(defun eval-forms (&rest forms)
(m-init-world)
(setf (machine-list *machine*)
(mapcar #'(lambda (x)
(make-job
arg-stack (ncons x)
job-expression x
pc-stack `(m-eval m-restore-env ,*environment*)
job-active 'alive))
forms))
t)
(defun eval-form (form)
(m-init-world)
(setf (machine-list *machine*)
`(,(make-job
arg-stack (ncons form)
job-expression form
pc-stack `(m-eval m-restore-env ,*environment*)
job-active 'alive)))
t)
(defun print-jobs ()
(do ((pr (machine-processors *machine*) (cdr pr))
(n 0))
((null pr)
(terpri)
(princ "Number of jobs: ")(princ n)(terpri))
(let ((first (car (qhead (processor-job-queue (car pr))))))
(do ((jobs (qhead (processor-job-queue (car pr)))
(cdr jobs))
(ojobs () (cdr jobs)))
((eq (car ojobs) first)
t)
(setq n (1+ n))
(terpri)
(princ (job-expression (car jobs)))
(tab)
(princ (job-active (car jobs)))
(tab)
(princ (job-waiter (car jobs)))))))
(defun meval (form)
(setq *meter* (make-meter))
(setq *catch-thread* ())
(setf (meter-processors *meter*) (machine-number *machine*))
(eval-form `(print (setq *val* ,form)))
(run *machine*)
(report))
(defun toplevel ()
(princ "=> ")
(do ((x (read)(read)))
(())
(cond ((not (atom x))
(cond ((memq (car x)
'(defmacro defun m-defun m-qdefun fasload))
(print (eval x)))
((eq (car x) 'setq)
(do ((l (cdr x) (cddr l)))
((null l) *val*)
(let ((*silence* t))
(meval (cadr l)))
(set (car l) *val*)))
(t
(meval x))))
(t (meval x)))
(terpri)
(princ "=> ")
))
(defun startup (n &optional (m (* 2 n)))
(make-multi-processor n)
(setq *number-of-processes* 0)
(setq *max-number-of-processes* m)
(terpri) (princ "Multi-processing Lisp with ")
(princ n) (princ " processors.")
(terpri)
(toplevel))